(in-package :iorek)

(defun sequence-to-seq (list)
  (cl:reduce #'with-last list :initial-value (seq)))

(defun seq-to-list (seq)
  (let (list)
    (do-seq (elem seq)
      (push elem list))
    (nreverse list)))

(defun translate-form (form &optional (environment *top-level-environment*))
  (cond
    ((typep form 'fset:seq)
     (cond
       ((empty? form) form)
       ((symbol-p (first form))
        (translate-compound-form (first form) (subseq form 1) environment))
       (t (error "Unsupported form head: ~S" (first form)))))
    ((and (vectorp form) (not (stringp form)))
     (translate-infix-expression form environment))
    ((symbol-p form)
     (translate-variable-read form environment))
    (t form)))

(defun translate-function-arguments (arguments environment)
  (let ((translated-args (list)))
    (do-seq (x arguments)
      (push (translate-form x environment) translated-args))
    (nreverse translated-args)))

(defun translate-compound-form (symbol arguments environment)
  (handler-case
      (multiple-value-bind (fn entry)
          (symbol-function symbol environment)
        (let ((kind (environment-entry-kind entry)))
          (cond
            ((eq kind :special-operator)
             (funcall fn arguments environment))
            ((or (eq kind :lisp-function) (eq kind :lisp-function-and-variable))
             `(,fn ,@(translate-function-arguments arguments environment)))
            ;;TODO prevent infinite recursion when the macro expands to the same form
            ((eq kind *symbol-kind-macro*)
             (translate-form
              (funcall fn symbol environment arguments)
              environment))
            (t `(funcall ,fn ,@(translate-function-arguments arguments environment))))))
    (unbound-symbol ()
      ;;TODO        (record-unbound-function-call symbol)
      `(funcall (symbol-function ,symbol *top-level-environment*)
                ,@(translate-function-arguments arguments environment)))))

(defun record-unbound-function-call (symbol)
  (warn "Unknown function called: ~S" symbol)) ;;TODO compilation-unit API

(defun find-infix-operator (vector)
  (let (index op (prec most-positive-fixnum))
    (loop
       :for i :from 0
       :for x :across vector
       :do (when (and (symbol-p x) (operator-p x)
                      (<= (operator-precedence x) prec))
             (setf index i
                   op x
                   prec (operator-precedence x))))
   (values index op prec)))

(defun infix-to-prefix (form)
  (multiple-value-bind (index op)
      (find-infix-operator form)
    (if op
        (let ((left (make-array index))
              (right (make-array (- (length form) index 1))))
          (dotimes (i (length left))
            (setf (aref left i) (aref form i)))
          (dotimes (i (length right))
            (setf (aref right i) (aref form (+ i index 1))))
          (fset:seq
           (fset:concat (fset:seq op)
                        (infix-to-prefix left)
                        (infix-to-prefix right))))
        (sequence-to-seq form))))

(defun translate-infix-expression (form environment)
  (unless (find-infix-operator form)
    (error "No operator in form ~A" form)) ;;TODO
  (translate-form (first (infix-to-prefix form)) environment))

(defun translate-variable-read (symbol environment)
  (handler-case
      (multiple-value-bind (value entry)
          (symbol-value symbol environment)
        (case (environment-entry-kind entry)
          ((:lexical-variable :lexical-function :lisp-variable :lisp-function-and-variable) value)
          (:lisp-function `(function ,value))
          (t `(values (symbol-value ,symbol *top-level-environment*))))) ;;TODO really top-level?
    (unbound-symbol ()
      (warn "Unkown variable read ~A" symbol) ;;TODO
      `(values (symbol-value ,symbol *top-level-environment*)))))

(defun translate-variable-write (symbol expression environment)
  (let ((expression (translate-form expression environment)))
    (handler-case
      (multiple-value-bind (place entry)
          (symbol-value symbol environment)
        (case (environment-entry-kind entry)
          ((:lexical-variable :lexical-function :lisp-variable :lisp-function-and-variable)
           `(setf ,place ,expression))
          (:lisp-function (error "~A is not assignable" place))
          (t `(record-definition ,symbol ,expression)))) ;;TODO really top-level?
      (unbound-symbol ()
        (warn "Unbound symbol write ~A" symbol) ;;TODO
        `(record-definition ,symbol ,expression)))))

(defgeneric load (source))

(defmethod load :around (source)
  (let ((*namespace* *namespace*))
    (call-next-method)))

(defmethod load ((stream stream))
  (loop
     (let ((form (read-expression stream)))
       (if form
           (eval (translate-form form))
           (return)))))

(defmethod load ((source pathname))
  (%load source))

(defmethod load ((source string))
  (%load source))

(defun %load (path)
  (if (probe-file (compile-file-pathname path)) ;;TODO: check timestamp!!
      (cl:load (compile-file-pathname path))
      (with-open-file (f path :direction :input)
        (load f))))

(defgeneric compile (source))

(defmethod compile ((source function))
  (cl:compile nil source))

(defmethod compile ((source pathname))
  (%compile-file source))

(defmethod compile ((source string))
  (%compile-file source))

(defvar *translated-expressions*)

(defun %compile-file (source)
  (let ((iorek-file (make-pathname :defaults source :type "iorek-compiler-temp"))
        (*read-eval* t)
        *translated-expressions*)
    (with-open-file (in source :direction :input)
      (with-open-file (out iorek-file :direction :output)
        (print '(in-package :iorek) out)
        (terpri out)
        (loop
           (let ((form (read-expression in)))
             (if form
                 (progn
                   (push (translate-form form) *translated-expressions*)
                   (princ "#.(CL:POP *TRANSLATED-EXPRESSIONS*)" out))
                 (return)))))
      (setf *translated-expressions* (nreverse *translated-expressions*))
      (let ((compiled-file (compile-file iorek-file)))
        (delete-file iorek-file)
        compiled-file))))

;;TODO (defmethod compile ((source seq)))

;;TODO (defmethod compile ((source stream)))